home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / package.tcl < prev    next >
Encoding:
Text File  |  1998-12-16  |  40.0 KB  |  1,331 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "package.tcl"
  6.  #                                    created: 2/8/97 {6:15:10 pm} 
  7.  #                                last update: 16/12/1998 {2:11:11 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1997-1998  Vince Darley, all rights reserved
  15.  # 
  16.  #  How to ensure packages are loaded in the correct order?
  17.  #  (some may require Vince's Additions).  Here perhaps we could
  18.  #  just use a Tcl8-like-approach: introduce a 'package' command
  19.  #  and have stuff like 'package Name 1.0 script-to-load'.
  20.  #  Then a package can just do 'package require Othername' to ensure
  21.  #  it is loaded.  I like this approach.
  22.  #  
  23.  #  How to initialise each package at startup?  If we use the above
  24.  #  scheme, then the startup script is purely a sequence of
  25.  #  'package require Name' commands.  The file 'prefs.tcl' is then
  26.  #  purely for user-meddling.  Packages do not need to store anything
  27.  #  there.  Sounds good to me.
  28.  #  
  29.  #  How to uninstall things?  One approach here is a 
  30.  #  'package uninstall Name' command.  Nice packages would provide
  31.  #  this.
  32.  #  
  33.  #  We need a default behaviour too.  Some packages require no
  34.  #  installation at all (except placing in a directory), others 
  35.  #  require sourcing, others need to add something to a menu.  How
  36.  #  much of this should be automated and how much is up to the
  37.  #  package author?
  38.  # 
  39.  # ----
  40.  # 
  41.  #  The solution below is to imitate Tcl 8.  There is a 'package'
  42.  #  mechanism.  There exists a index::feature() array which gives for
  43.  #  each package the means to load it --- a procedure name or a
  44.  #  'source file' command.  The package index is compiled 
  45.  #  automatically by recursively scanning all files in the
  46.  #  Packages directory for 'package name version do-this'
  47.  #  commands.
  48.  #  
  49.  #  There's also 'package names', 'package exists name', and an
  50.  #  important 'package require name version' which allows one
  51.  #  package to autoload another...
  52.  #  
  53.  # Pros of this approach: many packages, which would otherwise
  54.  # require an installation procedure, now can be just dropped
  55.  # in to the packages directory and they're installed! (After
  56.  # rebuilding the package index).  This is because 'package'
  57.  # can declare a snippet of code, an addition to a menu etc…
  58.  # ----
  59.  # 
  60.  # Thanks to Tom Fetherston for some improvements here.
  61.  # ###################################################################
  62.  ##
  63.  
  64. namespace eval package {}
  65. namespace eval date {}
  66. namespace eval remote {}
  67.  
  68. ## 
  69.  # -------------------------------------------------------------------------
  70.  # 
  71.  # "alpha::findAllExtensions" --
  72.  # 
  73.  #  package require all extensions the user has activated
  74.  # -------------------------------------------------------------------------
  75.  ##
  76. proc alpha::findAllExtensions {} {
  77.     global global::features index::feature alpha::systempackages
  78.     # this carries out the existence part of each feature
  79.     foreach m [array names index::feature] {
  80.     if {[lsearch -exact [set alpha::systempackages] $m] != -1} {
  81.         continue
  82.     }
  83.     set info [set index::feature($m)]
  84.     if {[string trim [lindex $info 3]] != ""} {
  85.         try::level \#0 [lindex [set index::feature($m)] 3] -reporting log -while "initialising $m"
  86.         set index::feature($m) [lreplace [set index::feature($m)] 3 3 ""]
  87.     }
  88.     }    
  89.     # remove any package which doesn't exist.
  90.     foreach m [set global::features] {
  91.     if {![info exists index::feature($m)]} {
  92.         set global::features [lremove ${global::features} $m]
  93.     } elseif {[lindex [set index::feature($m)] 2] == 0} {
  94.         package::activate $m
  95.     }
  96.     }
  97. }
  98.  
  99. proc package::addPrefsDialog {pkg} {
  100.     global package::prefs alpha::noMenusYet
  101.     lunion package::prefs $pkg
  102.     if {![info exists alpha::noMenusYet]} {
  103.     # we were called after start-up; build the menu now
  104.     menu::buildSome packagePrefs
  105.     }
  106. }
  107.  
  108. ## 
  109.  # -------------------------------------------------------------------------
  110.  # 
  111.  # "alpha::package" --
  112.  # 
  113.  #  Mimics the Tcl standard 'package' command for use with Alpha.
  114.  #  It does however have some differences.
  115.  #  
  116.  #  package require ?-exact? ?-extension -mode -menu? name version
  117.  #  package exists ?-extension -mode -menu? name version
  118.  #  package names ?-extension -mode -menu?
  119.  #  package uninstall name version
  120.  #  package vcompare v1 v2
  121.  #  package vsatisfies v1 v2
  122.  #  package versions ?-extension -mode -menu? name
  123.  #  package type name
  124.  #  package info name
  125.  #  package maintainer name version {name email web-page}
  126.  #  package modes 
  127.  #  
  128.  #  Equivalent to alpha::mode alpha::menu and alpha::extension
  129.  #  
  130.  #  package mode ...
  131.  #  package menu ...
  132.  #  package extension ...
  133.  #  
  134.  #  For extensions only:
  135.  #  
  136.  #  package forget name version
  137.  # -------------------------------------------------------------------------
  138.  ##
  139. proc alpha::package {cmd args} {
  140.     global index::feature
  141.     switch -- $cmd {
  142.     "require" {
  143.         set info [package::getInfo "exact loose"]
  144.         global alpha::rebuilding
  145.         if {[llength $info]} {
  146.         if {!${alpha::rebuilding} && [set version [lindex $args 1]] != ""} {
  147.             if {[info exists exact]} {
  148.             if {[lindex $info 0] != $version} {
  149.                 error "requested exact $version, had [lindex $info 0]"
  150.             }
  151.             } elseif {[info exists loose]} {
  152.             if {[alpha::package vcompare [lindex $info 0] $version] < 0} {
  153.                 error "requested $version or newer, had [lindex $info 0]"
  154.             }
  155.             } elseif {![alpha::package vsatisfies [lindex $info 0] $version]} {
  156.             error "requested $version, had [lindex $info 0]"
  157.             }
  158.         }
  159.         if {$type == "feature"} {
  160.             global package::loaded alpha::noMenusYet \
  161.               errorCode errorInfo
  162.             package::activate $name
  163.         }
  164.         return [lindex $info 0]
  165.         }
  166.         if {!${alpha::rebuilding}} {
  167.         error "can't find package $name"
  168.         }
  169.     }
  170.     "uninstall" {
  171.         set name [lindex $args 0]
  172.         if {[llength $args] > 2} {
  173.         set version [lindex $args 1]
  174.         global alpha::rebuilding 
  175.         if {${alpha::rebuilding}} {
  176.             global rebuild_cmd_count index::uninstall pkg_file
  177.             switch -- [set script [lindex $args 2]] {
  178.             "this-file" {
  179.                 set script [list file delete $pkg_file]
  180.             }
  181.             "this-directory" {
  182.                 set script [list rm -r [file dirname $pkg_file]]
  183.             }
  184.             }
  185.             set index::uninstall($name) [list $version $pkg_file $script]
  186.             set args [lrange $args 3 end]
  187.             if {[llength $args]} {
  188.             eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  189.             return
  190.             }
  191.             if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  192.             return -code 11
  193.             }
  194.         }
  195.         } else {
  196.         cache::read index::uninstall
  197.         return [set index::uninstall($name)]
  198.         }
  199.     }
  200.     "forget" {
  201.         catch {unset index::feature($name)}
  202.     }
  203.     "exists" {
  204.         if {[package::getInfo] != ""} {return 1} else {return 0}
  205.     }
  206.     "type" {
  207.         if {[package::getInfo] != ""} {return $type} 
  208.         error "No such package"
  209.     }
  210.     "info" {
  211.         if {[llength [set info [package::getInfo]]]} {return [concat $type $info]} 
  212.         error "No such package"
  213.     }
  214.     "maintainer" -
  215.     "disable" -
  216.     "help" {
  217.         set name [lindex $args 0]
  218.         if {[llength $args] > 2} {
  219.         global alpha::rebuilding 
  220.         if {${alpha::rebuilding}} {
  221.             set version [lindex $args 1]
  222.             global rebuild_cmd_count index::$cmd
  223.             set data [lindex $args 2]
  224.             set index::${cmd}($name) [list $version $data]
  225.             set args [lrange $args 3 end]
  226.             if {[llength $args]} {
  227.             eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  228.             return
  229.             }
  230.             if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  231.             return -code 11
  232.             }
  233.         }
  234.         } else {
  235.         cache::read index::$cmd
  236.         return [set index::${cmd}($name)]
  237.         }
  238.     }
  239.     "versions" {
  240.         set info [package::getInfo]
  241.         if {[llength $info]} {
  242.         return [lindex $info 0]
  243.         }
  244.         error "No such package"
  245.     }
  246.     "vcompare" {
  247.         set c [eval package::_versionCompare $args]
  248.         if {$c > 0 || $c == -3} {
  249.         return 1
  250.         } elseif {$c == 0} {
  251.         return 0
  252.         } else {
  253.         return -1
  254.         }
  255.     }
  256.     "vsatisfies" {
  257.         if {[lindex $args 0] == "-loose"} {
  258.         set c [eval package::_versionCompare [lrange $args 1 end]]
  259.         return [expr {$c >= 0 || $c == -3 ? 1 : 0}]
  260.         } else {
  261.         set c [eval package::_versionCompare $args]
  262.         return [expr {$c >= 0 ? 1 : 0}]
  263.         }
  264.     }
  265.     "names" {
  266.         set names ""
  267.         package::getInfo
  268.         foreach type $which {
  269.         if {[array exists index::${type}]} {
  270.             eval lappend names [array names index::${type}]
  271.         }
  272.         }
  273.         return $names
  274.     }
  275.     "mode" -
  276.     "menu" -
  277.     "feature" {
  278.         eval alpha::$cmd $args
  279.     }
  280.     default {
  281.         error "Unknown option '$cmd' to 'package'"
  282.     }
  283.     }
  284. }
  285.  
  286. proc package::getInfo {{flags ""}} {
  287.     uplevel [list set flags $flags]
  288.     uplevel {
  289.     set name [lindex $args 0]
  290.     if {[regexp -- {-([^-].*)} $name "" which]} {
  291.         if {[lsearch $flags $which] != -1} {
  292.         set $which 1
  293.         set name [lindex $args 1]            
  294.         set args [lrange $args 1 end]            
  295.         return [package::getInfo $flags]
  296.         }
  297.         if {[lsearch {feature mode} $which] == -1} {
  298.         error "No such flag -$which"
  299.         }
  300.         set name [lindex $args 1]
  301.         set args [lrange $args 1 end]
  302.     } else {
  303.         set which {feature mode}
  304.     }
  305.     foreach type $which {
  306.         if {$type != "feature"} {cache::read index::${type}}
  307.         if {[info exists index::${type}($name)]} {
  308.         return [set index::${type}($name)]
  309.         }
  310.     }
  311.     return ""
  312.     }    
  313. }
  314.  
  315. ## 
  316.  # -------------------------------------------------------------------------
  317.  # 
  318.  # "package::_versionCompare" --
  319.  # 
  320.  #  This proc compares the two version numbers.  It returns:
  321.  #  
  322.  #  0 equal
  323.  #  1 equal but beta/patch update
  324.  #  2 equal but minor update
  325.  #  -1 beta/patch version older
  326.  #  -2 minor version older
  327.  #  -3 major version newer
  328.  #  -5 major version older
  329.  #  
  330.  #  i.e. >= 0 is basically ok, < 0 basically bad
  331.  #  
  332.  #  It works for beta, alpha, dev, fc and patch version numbers.
  333.  #  Any sequence of letters starting b,a,d,f,p are assumed to
  334.  #  represent the particular item.
  335.  #  
  336.  #  2.4 > 1.5 > 1.4.3 > 1.4.3b2 > 1.4.3b1 > 1.4.3a75 > 1.4p1 > 1.4
  337.  # -------------------------------------------------------------------------
  338.  ##
  339. proc package::_versionCompare {v1 v2} {
  340.     regsub -all -nocase {([a-z])[a-z]+} $v1 {\1} v1
  341.     regsub -all -nocase {([a-z])[a-z]+} $v2 {\1} v2
  342.     set v1 [split $v1 .p]
  343.     set v2 [split $v2 .p]
  344.     set i -1
  345.     set ret 0
  346.     set mult 2
  347.     while 1 {
  348.     incr i
  349.     set sv1 [lindex $v1 0]
  350.     set sv2 [lindex $v2 0]
  351.     if {$sv1 == "" && $sv2 == ""} { break }
  352.     if {$sv1 == ""} { 
  353.         set v1 [concat 8 0 $v1]
  354.         set v2 [concat 9 $v2]
  355.         continue
  356.     } elseif {$sv2 == ""} { 
  357.         set v1 [concat 9 $v1]
  358.         set v2 [concat 8 0 $v2]
  359.         continue
  360.     } elseif {[regexp -nocase {[a-z]} "$sv1$sv2"]} {
  361.         # beta versions
  362.         foreach v {sv1 sv2} {
  363.         if {[regexp -nocase {[a-z]} [set $v]]} {
  364.             # f = 8, b = 7, a = 6, d = 5
  365.             regsub -nocase {([^a-z])f} [set $v] {\1 7 } $v
  366.             regsub -nocase {([^a-z])b} [set $v] {\1 6 } $v
  367.             regsub -nocase {([^a-z])a} [set $v] {\1 5 } $v
  368.             regsub -nocase {([^a-z])d} [set $v] {\1 4 } $v
  369.         } else {
  370.             # release version = 8, so it is larger than any of the above
  371.             append $v " 8"
  372.         }
  373.         }
  374.         set v1 [eval lreplace [list $v1] 0 0 $sv1]
  375.         set v2 [eval lreplace [list $v2] 0 0 $sv2]
  376.         set mult 1
  377.         continue
  378.     }
  379.     if {$sv1 < $sv2} { set ret -1 ; break }
  380.     if {$sv1 > $sv2} { set ret 1 ; break }
  381.     set v1 [lrange $v1 1 end]
  382.     set v2 [lrange $v2 1 end]
  383.     }
  384.     if {$i == 0} {
  385.     # major version, return 0, -3, -5
  386.     return [expr {$ret * (-4*$ret + 1)}]
  387.     } else {
  388.     return [expr {$mult *$ret}]
  389.     }
  390. }
  391.  
  392. proc package::versionCheck {name vers} {
  393.     set av [alpha::package versions $name]
  394.     set c [package::_versionCompare $av $vers]
  395.     if {$c < 0 && $c != -3} {            
  396.     error "The installed version $av of '$name' is too old. Version $vers was requested."
  397.     } elseif {$c == -3} {            
  398.     error "The installed version $av of '$name' may not be backwards compatible with the requested version ($vers)."
  399.     }            
  400. }
  401.  
  402. proc package::reqInstalledVersion {name exact? {reqvers ""}} {
  403.     global index::feature
  404.     # called from installer
  405.     set msg " I suggest you abort the installation."
  406.     if {[info exists index::feature($name)]} {
  407.     if {[set exact?] == ""} {return}
  408.     set av [alpha::package versions $name]
  409.     if {[set exact?] == "-exact"} {
  410.         if {[alpha::package versions $name] != $reqvers} {
  411.         alertnote "The installed version $av of '$name' is incorrect.  Exact version $reqvers was requested.$msg"
  412.         }
  413.     } else {
  414.         set reqvers [set exact?]
  415.         if {$reqvers != ""} {        
  416.         set c [package::_versionCompare $av $reqvers]            
  417.         if {$c < 0 && $c != -3} {            
  418.             alertnote "The installed version $av of '$name' is too old. Version $reqvers was requested.$msg"
  419.         } elseif {$c == -3} {            
  420.             alertnote "The installed version $av of '$name' may not be backwards compatible with the requested version ($reqvers).$msg"
  421.         }             
  422.         }        
  423.     }
  424.     } else {
  425.     alertnote "This package requires the prior installation of '$name'. It is not currently installed.$msg"
  426.     }
  427. }
  428.  
  429. proc package::checkRequire {pkg} {
  430.     if {[catch {alpha::package require $pkg} error]} {
  431.     global errorInfo ; echo $errorInfo
  432.     if {[catch {alertnote "The '$pkg' package had an error starting up: $error"} ]} {
  433.         alertnote "The '$pkg' package had an error starting up"
  434.         echo $error
  435.     }
  436.     }    
  437. }
  438.  
  439.  
  440.  
  441. proc package::queryWebForList {} {
  442.     global defaultAlphaDownloadSite remote::site PREFS
  443.     set sitename [dialog::variable defaultAlphaDownloadSite "Query which site?"]
  444.     set nm [file join ${PREFS} _pkgtemp]
  445.     set siteurl [set remote::site($sitename)]
  446.     
  447.     catch {file delete $nm}
  448.     message "Fetching remote list…"
  449.     set type [url::fetch $siteurl $nm]
  450.     package::okGotTheList $sitename
  451. }
  452.  
  453. ## 
  454.  # -------------------------------------------------------------------------
  455.  # 
  456.  # "package::okGotTheList" --
  457.  # 
  458.  #  Helper proc which we can also call if the listing was interrupted
  459.  #  half-way through.
  460.  # -------------------------------------------------------------------------
  461.  ##
  462. proc package::okGotTheList {{sitename ""}} {
  463.     global defaultAlphaDownloadSite remote::site PREFS remote::lastsite
  464.     if {$sitename == ""} {
  465.     if {[info exists remote::lastsite]} {
  466.         set sitename ${remote::lastsite}
  467.         unset remote::lastsite
  468.     } else {
  469.         set sitename [dialog::variable defaultAlphaDownloadSite "From which site did you get the list?"]
  470.     }
  471.     }
  472.     set type [lindex [url::parse [set remote::site($sitename)]] 0]
  473.     set nm [file join ${PREFS} _pkgtemp]
  474.     if {![file exists $nm] || (![file writable $nm]) || (![file size $nm])} {
  475.     alertnote "It looks like that application returned control\
  476.       to me before the download was complete (otherwise there was an error)\
  477.       -- probably Netscape/IE.  When it's done, or if there was an error\
  478.       hit Ok."
  479.     }
  480.     if {![file exists $nm] || (![file writable $nm]) || (![file size $nm])} {
  481.     alertnote "There was a problem fetching the list --- if it's still\
  482.       being downloaded (you hit Ok too early!), wait till it's done \
  483.       and then select 'Ok Got The List'\
  484.       from the downloads menu."
  485.     set remote::lastsite $sitename
  486.     enableMenuItem -m internetUpdates "Ok, Got The List" on
  487.     error "Error fetching list of new packages"
  488.     } else {
  489.     enableMenuItem -m internetUpdates "Ok, Got The List" off
  490.     }
  491.     set fd [open $nm "r"]
  492.     catch {set lines [split [read $fd] "\n\r"]}
  493.     close $fd
  494.     
  495.     if {[catch [list remote::process${type}Listing $lines] listing]} {
  496.     alertnote "Error interpreting list of new packages"
  497.     error "Error interpreting list of new packages"
  498.     }
  499.     message "Processing list…"
  500.     remote::processList $sitename $listing
  501.     message "Updated remote package information."
  502. }
  503.  
  504. proc package::active {pkg {text ""}} {
  505.     global global::features mode::features mode
  506.     if {[lsearch -exact ${global::features} $pkg] != -1 \
  507.       || ($mode != "" && ([lsearch -exact [set mode::features($mode)] $pkg] != -1))} {
  508.     if {[llength $text]} { return [lindex $text 0] } else {return 1 }
  509.     } else {
  510.     if {[llength $text]} { return [lindex $text 1] } else {return 0 }
  511.     }
  512. }
  513.  
  514. proc package::_editSite {{name ""} {loc ""}} {
  515.     if {$name == ""} {
  516.     set title "Name of new archive site"
  517.     set name "Ken's Alpha site"
  518.     set loc "ftp://ftp.ken.com/pub/Alpha/"
  519.     } else {
  520.     set title "Archive site name"
  521.     }
  522.     set y 10
  523.     set yb 105
  524.     set res [eval dialog -w 420 -h 135 \
  525.       [dialog::textedit $title $name 10 y 40] \
  526.       [dialog::textedit "URL for site" $loc 10 y 40] \
  527.       [dialog::okcancel 250 yb 0]]
  528.     if {[lindex $res 3]} { error "Cancel" } 
  529.     # cancel was pressed
  530.     return [lrange $res 0 1]    
  531. }
  532.  
  533.  
  534. proc package::addIndex {args} {
  535.     global index::feature pkg_file
  536.     cache::read index::feature
  537.     foreach f [concat $args] {
  538.     set pkg_file $f
  539.     message "scanning $f…"
  540.     catch {source $f}
  541.     }
  542.     cache::create index-extension "variable" index::feature
  543.     unset pkg_file
  544. }
  545.  
  546. proc package::helpFile {pkg {pointer 0}} {
  547.     # read help file instead
  548.     global HOME
  549.     set v [alpha::package versions $pkg]
  550.     if {[lindex $v 0] == "mode"} {
  551.     set v [lindex $v 1]
  552.     alertnote "The '$pkg' package is implemented by $v mode, and has no separate help.  I'll display the help for that mode instead."
  553.     set pkg $v
  554.     }
  555.     if {![catch {alpha::package help $pkg} res]} {
  556.     if {[lindex [set help [lindex $res 1]] 0] == "file"} {
  557.         if {$pointer} {
  558.         return "Help for this package is located in \"[lindex $help 1]\""
  559.         } else {
  560.         edit -r -c [file join ${HOME} Help [lindex $help 1]]
  561.         }
  562.     } elseif {[string index $help 0] == "\["} {
  563.         if {$pointer} {
  564.         return "You can read help for this package by holding 'shift' when\ryou select its name in the menu."
  565.         } else {
  566.         uplevel \#0 [string range $help 1 [expr {[string length $help] - 2}]]
  567.         }
  568.     } else {
  569.         if {$pointer} {
  570.         return $help
  571.         } else {
  572.         new -n "* '$pkg' Help *"
  573.         insertText "Help for package '$pkg', version [alpha::package versions $pkg]\r"
  574.         insertText $help
  575.         winReadOnly
  576.         }
  577.     }
  578.     return
  579.     }
  580.     if {!$pointer} {
  581.     alertnote "Sorry, there isn't a help file for that package. You should contact the package maintainer."
  582.     }
  583.     return
  584. }
  585.  
  586. ## 
  587.  # -------------------------------------------------------------------------
  588.  # 
  589.  # "package::helpFilePresent" --
  590.  # 
  591.  #  Help files must be of the same name as the package (minus 'mode' or 
  592.  #  'menu'), but may have any combination of mode, menu, or help after
  593.  #  that name.  Whitespace is irrelevant.
  594.  # -------------------------------------------------------------------------
  595.  ##
  596. proc package::helpFilePresent {args} {
  597.     set res ""
  598.     cache::read index::help
  599.     foreach pkg $args {
  600.     lappend res [info exists index::help($pkg)]
  601.     }
  602.     return $res
  603. }
  604.  
  605. proc package::helpOrDescribe {pkg} {
  606.     if {[set mods [expr {[getModifiers] & 0xfe}]]} {
  607.     if {$mods & 34} {
  608.         package::helpFile $pkg
  609.     } else {
  610.         package::describe $pkg
  611.     }
  612.     return 1
  613.     }
  614.     return 0
  615. }
  616.  
  617. # ◊◊◊◊ Specific to 'features' ◊◊◊◊ #
  618.  
  619. proc package::addRelevantMode {_feature mode} {
  620.     global index::feature
  621.     if {[info exists index::feature($_feature)]} {
  622.     if {[lsearch -exact [set oldm [lindex [set index::feature($_feature)] 1]] $mode] != -1} {
  623.         return
  624.     }
  625.     lappend oldm $mode
  626.     set index::feature($_feature) \
  627.       [lreplace [set index::feature($_feature)] 1 1 $oldm]
  628.     } else {
  629.     set index::feature($_feature) [list [list "mode" $mode] $mode]
  630.     }
  631. }
  632.  
  633. proc package::removeRelevantMode {_feature mode} {
  634.     global index::feature
  635.     if {[info exists index::feature($_feature)]} {
  636.     if {[set idx [lsearch -exact [set oldm [lindex [set index::feature($_feature)] 1]] $mode]] == -1} {
  637.         return
  638.     }
  639.     set oldm [lreplace $oldm $idx $idx ""]
  640.     set index::feature($_feature) \
  641.       [lreplace [set index::feature($_feature)] 1 1 $oldm]
  642.     }
  643. }
  644.  
  645. ## 
  646.  # -------------------------------------------------------------------------
  647.  # 
  648.  # "package::onOrOff" --
  649.  # 
  650.  #  Complicated procedure to accomplish a relatively simple task!
  651.  #  
  652.  #  Given a list of packages from chosen in a dialog, possibly with
  653.  #  '-' prefixes to indicate 'off', work out what changes have to
  654.  #  be made to the set of on/off features to synchronise everything.
  655.  #  
  656.  #  If 'global' that means the list was of the global packages rather
  657.  #  than those for the current mode.
  658.  # -------------------------------------------------------------------------
  659.  ##
  660. proc package::onOrOff {pkgs {lastMode ""} {global 0}} {
  661.     global mode::features global::features
  662.     set oldfeatures ""
  663.     set offfeatures ""
  664.     set onfeatures ""
  665.     set newfeatures ""
  666.     foreach m $pkgs {
  667.     if {[string index $m 0] == "-"} {
  668.         set m [string range $m 1 end]
  669.         if {[lsearch -exact ${global::features} $m] >= 0} {
  670.         lappend offfeatures $m
  671.         }
  672.     } else {
  673.         if {[lsearch -exact ${global::features} $m] < 0} {
  674.         lappend newfeatures $m
  675.         }
  676.     }
  677.     }
  678.     if {$global} {
  679.     # turn off those which aren't there
  680.     set offfeatures [lremove -l [set global::features] $pkgs]
  681.     }
  682.     if {[info exists mode::features($lastMode)]} {
  683.     foreach m [set mode::features($lastMode)] {
  684.         if {[string index $m 0] == "-"} {
  685.         set m [string range $m 1 end]
  686.         if {$global} {
  687.             lappend oldfeatures $m
  688.         } else {
  689.             if {[lsearch -exact ${global::features} $m] >= 0} {
  690.             if {[set ip [lsearch -exact $offfeatures $m]] < 0} {
  691.                 lappend newfeatures $m
  692.             } else {
  693.                 set offfeatures [lreplace $offfeatures $ip $ip]
  694.             }
  695.             }
  696.         }
  697.         } else {
  698.         if {$global} {
  699.             if {[set ip [lsearch -exact $offfeatures $m]] >= 0} {
  700.             set offfeatures [lreplace $offfeatures $ip $ip]
  701.             }
  702.         } else {
  703.             if {[lsearch -exact ${global::features} $m] < 0} {
  704.             lappend oldfeatures $m
  705.             if {[lsearch -exact $newfeatures $m] < 0} {
  706.                 lappend offfeatures $m
  707.             }
  708.             }
  709.         }
  710.         }
  711.     }
  712.     }
  713.     foreach m $newfeatures {
  714.     if {[lsearch -exact $oldfeatures $m] < 0} {
  715.         lappend onfeatures $m
  716.     }
  717.     }
  718.     return [list $offfeatures $onfeatures]
  719. }
  720.  
  721. proc package::partition {{mode ""}} {
  722.     global index::feature
  723.     set a ""
  724.     set b ""
  725.     set c ""
  726.     if {$mode == ""} {
  727.     # global case
  728.     foreach n [lsort -ignore [alpha::package names]] {
  729.         if {[info exists index::feature($n)]} {
  730.         switch -- [lindex [set index::feature($n)] 2] {
  731.             "1" {
  732.             lappend a $n
  733.             }
  734.             default {
  735.             lappend b $n
  736.             }
  737.         }
  738.         } else {
  739.         lappend c $n
  740.         }
  741.     }
  742.     return [list $a $b $c]
  743.     } else {
  744.     set d ""
  745.     set e ""
  746.     set f ""
  747.     set partition [array names index::feature]
  748.     if {$mode == "global"} {
  749.         set mode "global*"
  750.         set search "-glob"
  751.     } else {
  752.         set search "-exact"
  753.         global global::features
  754.         set partition [lremove -l $partition ${global::features}]
  755.     }        
  756.     foreach n [lsort -ignore $partition] {
  757.         set ff [set index::feature($n)]
  758.         switch -- [lindex $ff 2] {
  759.         "1" {
  760.             if {[lsearch $search [lindex $ff 1] $mode] != -1} {
  761.             lappend a $n
  762.             } elseif {[lsearch -exact [lindex $ff 1] "global"] != -1} {
  763.             lappend b $n
  764.             } elseif {[lindex $ff 1] != "global-only"} {
  765.             lappend c $n
  766.             }
  767.         }
  768.         "0" {
  769.             if {[lsearch $search [lindex $ff 1] $mode] != -1} {
  770.             lappend d $n
  771.             } elseif {[lsearch -exact [lindex $ff 1] "global"] != -1} {
  772.             lappend e $n
  773.             } elseif {[lindex $ff 1] != "global-only"} {
  774.             lappend f $n
  775.             }
  776.         }
  777.         }
  778.     }
  779.     return [list $a $b $c $d $e $f]
  780.     }    
  781. }
  782.  
  783.  
  784. proc package::describe {pkg {return 0}} {
  785.     set info [alpha::package info $pkg]
  786.     set type [lindex $info 0]
  787.     set v [alpha::package versions $pkg]
  788.     if {[lindex $v 0] == "mode"} {
  789.     set v [lindex $v 1]
  790.     set msg "Package '$pkg', designed for use by $v mode is a"
  791.     } else {
  792.     set msg "Package '$pkg', version $v is a"
  793.     }
  794.     
  795.     switch -- $type {
  796.     "feature" {
  797.         switch -- [lindex $info 3] {
  798.         "0" {
  799.             append msg " $type, and is [package::active $pkg {active inactive}]."
  800.         }
  801.         "1" {
  802.             append msg " menu, and is "
  803.             global global::menus
  804.             if {![lcontains global::features $pkg]} {
  805.             append msg "not "
  806.             }
  807.             append msg "in use."
  808.         }
  809.         "-1" {
  810.             append msg "n autoloading $type."
  811.         }
  812.         }
  813.     }
  814.     "mode" {
  815.         append msg " $type; modes are always active."
  816.     }
  817.     }
  818.     cache::read index::maintainer
  819.     if {[info exists index::maintainer($pkg)]} {
  820.     set p [lindex [set index::maintainer($pkg)] 1]
  821.     append msg "\rMaintainer: [lindex $p 0], [lindex $p 1]\r"
  822.     append msg [lindex $p 2]
  823.     }
  824.     if {$return} {
  825.     return $msg
  826.     }
  827.     # let package tell us where its prefs are stored.
  828.     global alpha::prefs
  829.     if {[info exists alpha::prefs($pkg)]} {
  830.     set pkgpref [set alpha::prefs($pkg)]
  831.     } else {
  832.     set pkgpref $pkg
  833.     }
  834.     global ${pkgpref}modeVars
  835.     if {[array exists ${pkgpref}modeVars]} {
  836.     append msg "\r\r" [mode::describeVars $pkg $pkgpref]
  837.     new -n "* <$pkg> description *" -m Tcl
  838.     insertText $msg
  839.     winReadOnly
  840.     } else {
  841.     alertnote $msg
  842.     }
  843. }
  844.  
  845. proc package::deactivate {pkg} {
  846.     global index::feature
  847.     try::level \#0 [lindex [set index::feature($pkg)] 5] -reporting log -while "deactivating $pkg"
  848. }
  849.  
  850. proc package::activate {pkg} {
  851.     global index::feature
  852.     if {[set init [lindex [set index::feature($pkg)] 3]] != ""} {
  853.     message "Loading package '$pkg'…"
  854.     try::level \#0 $init -reporting log -while "initialising $pkg" 
  855.     set index::feature($pkg) [lreplace [set index::feature($pkg)] 3 3 ""]
  856.     }
  857.     try::level \#0 [lindex [set index::feature($pkg)] 4] -reporting log -while "activating $pkg"
  858. }
  859.  
  860. proc package::uninstall {} {
  861.     cache::read index::uninstall
  862.     if {![llength [set pkgs [array names index::uninstall]]]} {
  863.     alertnote "I don't know how to uninstall anything."
  864.     return
  865.     }
  866.     set pkg [dialog::optionMenu "Permanently remove which package/mode/menu?" [lsort -ignore $pkgs]]
  867.     if {![dialog::yesno "Are you absolutely sure you want to uninstall $pkg?"]} { 
  868.     return 
  869.     }
  870.     global pkg_file
  871.     set pkg_file [lindex [set index::uninstall($pkg)] 1]
  872.     set script [lindex [set index::uninstall($pkg)] 2]
  873.     if {[regexp "rm -r\[^\r\n\]*" $script check]} {
  874.     if {![dialog::yesno "This uninstaller contains a recursive removal command '$check'. Do you want to do this?"]} { 
  875.         return 
  876.     }
  877.     }
  878.     if {[catch "uplevel \#0 [list $script]"]} {
  879.     alertnote "The uninstaller had problems!"
  880.     }
  881.     if {[dialog::yesno "All indices must now be rebuilt.\rShall I do this for you?"]} {
  882.     alpha::rebuildPackageIndices
  883.     rebuildTclIndices
  884.     } else {
  885.     alertnote "This will probably cause problems."
  886.     }
  887.     if {[dialog::yesno "It is recommended that you quit and restart Alpha.  Quit now?"]} {
  888.     quit
  889.     }
  890. }
  891.  
  892. ## 
  893.  # -------------------------------------------------------------------------
  894.  # 
  895.  # "date::isOlder" --
  896.  # 
  897.  #  {Aug 22 1996} {Mar 26 22:17}
  898.  #  
  899.  # We assume the format is 'Month Day Year' or 'Month Day Time', where
  900.  # a time is distinguished by the presence of a colon.  Months have
  901.  # to be the standard three letter abbreviation (seems ok for all
  902.  # ftp and http servers I've come across)
  903.  # -------------------------------------------------------------------------
  904.  ##
  905. proc date::isOlder {a b} {
  906.     if {$a == $b} { return 0 }
  907.     regexp {(\w+)[ \t]+(\w+)[ \t]+([\w:]+)} $a "" am ad ay
  908.     regexp {(\w+)[ \t]+(\w+)[ \t]+([\w:]+)} $b "" bm bd by
  909.     # check year
  910.     regexp {[0-9]+$} [lindex [mtime [now] abbrev] 0] thisy
  911.     if {$ay == $thisy} { set ay "00:00" }
  912.     if {$by == $thisy} { set by "00:00" }
  913.     set a_ist [regexp : $ay]
  914.     set b_ist [regexp : $by]
  915.     if {!$a_ist && !$b_ist} {
  916.     if { $ay < $by } { return 1 } elseif {$by < $ay} { return 0}
  917.     }
  918.     if {$a_ist && !$b_ist} { return 0 }
  919.     if {!$a_ist && $b_ist} { return 1 }
  920.     # both are a year or both are times and both in last year
  921.     set months {Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}
  922.     # check we don't have a year wrap-around problem
  923.     set now [lindex [mtime [now] short] 0]
  924.     set refdate [lindex [mtime 2976439308 short] 0]
  925.     if {$refdate == "4/26/98"} {
  926.     # US
  927.     regexp {([0-9]+)/([0-9]+)} $now "" now_m now_d
  928.     } elseif {$refdate == "98-04-26"} {
  929.     # Swedish
  930.     regexp {[0-9]+-([0-9]+)-([0-9]+)} $now "" now_m now_d
  931.     } else {
  932.     # Other
  933.     regexp {([0-9]+)[-/\.]([0-9]+)} $now "" now_d now_m
  934.     }
  935.     set am [lsearch $months $am]
  936.     set bm [lsearch $months $bm]
  937.     set aprev [expr {($now_m < $am || ($now_m == $am && $now_d < $ad))}]
  938.     set bprev [expr {($now_m < $bm || ($now_m == $bm && $now_d < $bd))}]
  939.     if {$aprev && !$bprev} {return 1}
  940.     if {!$aprev && $bprev} {return 0}
  941.     # both in same year: continue
  942.     if {$am < $bm} { return 1 } elseif {$bm < $am} { return 0 }
  943.     if {$ad < $bd} { return 1 } elseif {$bd < $ad} { return 0 }
  944.     if {$a_ist && $b_ist} {
  945.     regsub {:} $ay {.} ay
  946.     regsub {:} $by {.} by
  947.     if { $ay < $by } { return 1 } elseif {$by < $ay} { return 0}
  948.     } 
  949.     # same !
  950.     return 0
  951. }
  952.  
  953.  
  954. # ◊◊◊◊ Handle remote menu ◊◊◊◊ #
  955. proc package::menuProc {menu item} {
  956.     global remote::site modifiedArrVars defaultAlphaDownloadSite
  957.     switch -- $item {
  958.     "Describe A Package" {
  959.         set pkg [dialog::optionMenu "Describe which package?" \
  960.           [lsort -ignore [alpha::package names]]]
  961.         package::describe $pkg
  962.     }
  963.     "Read Help For A Package" {
  964.         set pkg [dialog::optionMenu "Read help for which package?" \
  965.           [lsort -ignore [alpha::package names]]]
  966.         package::helpFile $pkg
  967.     }
  968.     "Uninstall A Package" {
  969.         package::uninstall
  970.     }
  971.     "rebuildPackageIndex" {
  972.         alpha::rebuildPackageIndices
  973.     }
  974.     "listPackages" {
  975.         global::listPackages
  976.     }
  977.     "installBugFixesFrom" {
  978.         # this item isn't in the menu by default anymore.
  979.         set f [getfile "Select a bug-fix file…"]
  980.         procs::patchOriginalsFromFile $f 1
  981.     }
  982.     "Update List From A Web Archive Site" {
  983.         package::queryWebForList
  984.     }
  985.     "Ok, Got The List" {
  986.         package::okGotTheList
  987.     }
  988.     "Add Web Or Ftp Archive Site" {
  989.         array set remote::site [package::_editSite]
  990.         lappend modifiedArrVars remote::site
  991.     }
  992.     "Edit Web Or Ftp Archive Site" {
  993.         set sitename [dialog::optionMenu "Edit which site?" \
  994.           [lsort -ignore [array names remote::site]]]
  995.         
  996.         array set remote::site \
  997.           [package::_editSite $sitename [set remote::site($sitename)]]
  998.         lappend modifiedArrVars remote::site
  999.     }
  1000.     "Remove Web Or Ftp Archive Site" {
  1001.         set sitename [dialog::optionMenu "Remove which site?" \
  1002.           [lsort -ignore [array names remote::site]]]
  1003.         unset remote::site($sitename)
  1004.         lappend modifiedArrVars remote::site
  1005.     }
  1006.     "Describe Item" {
  1007.         alertnote "Select one of the packages, and I'll tell you\
  1008.           when it was last modified, and from where it would be downloaded."
  1009.     }
  1010.     "Ignore Item" {
  1011.         alertnote "'Ignoring' a package tells me to remove it from\
  1012.           new and updated package lists.  It'll still be listed lower\
  1013.           down in the menu"
  1014.     }
  1015.     "Select Item To Download" {
  1016.         alertnote "Select one of the packages, and it will be\
  1017.           downloaded from its site on the internet, decompressed\
  1018.           and installed."
  1019.     }
  1020.     default {
  1021.         remote::get $item
  1022.     }
  1023.     }
  1024.     
  1025. }
  1026.  
  1027.  
  1028. proc package::makeMenu {} {
  1029.     global remote::listing
  1030.     set l [list \
  1031.       "Update List From A Web Archive Site…" \
  1032.       "(Ok, Got The List" \
  1033.       "<E<SRemove Web Or Ftp Archive Site…" \
  1034.       "<S<BEdit Web Or Ftp Archive Site…" \
  1035.       "<SAdd Web Or Ftp Archive Site…" "(-" \
  1036.       "<S[menu::itemWithIcon {Describe Item} 81]" \
  1037.       "<S<U[menu::itemWithIcon {Ignore Item} 81]" \
  1038.       "<S[menu::itemWithIcon {Select Item To Download} 81]" ]
  1039.     foreach a ${remote::listing} {
  1040.     set type [lindex $a 1]
  1041.     regsub -all {\.(sit|bin|hqx)} [set name [lindex $a 2]] "" name
  1042.     lappend [lindex {other gone new uptodate update} [expr {$type + 2}]] $name
  1043.     if {$type == -1} {
  1044.         lappend disable $name
  1045.     }
  1046.     }
  1047.     if {[info exists update]} {
  1048.     lappend l "(-" "/\x1e(Updated items^[text::Ascii 79 1]"
  1049.     eval lappend l [lsort -ignore $update]
  1050.     }
  1051.     if {[info exists new]} {
  1052.     lappend l "(-" "/\x1e(New items^[text::Ascii 79 1]"
  1053.     eval lappend l [lsort -ignore $new]
  1054.     }
  1055.     if {[info exists uptodate]} {
  1056.     lappend l "(-" "(Current items"
  1057.     eval lappend l [lsort -ignore $uptodate]
  1058.     }
  1059.     if {[info exists other]} {
  1060.     lappend l "(-" "(Other items"
  1061.     eval lappend l [lsort -ignore $other]
  1062.     }
  1063.     if {[info exists gone]} {
  1064.     lappend l "(-" "(Vanished items"
  1065.     eval lappend l [lsort -ignore $gone]
  1066.     }
  1067.     Menu -n "internetUpdates" -m -p package::menuProc $l
  1068.     if {[info exists disable]} {
  1069.     foreach a $disable {
  1070.         enableMenuItem "internetUpdates" $a off
  1071.     }
  1072.     }
  1073. }
  1074.  
  1075. proc remote::processftpListing {lines} {
  1076.     set files {}
  1077.     foreach f [lrange [lreplace $lines end end] 1 end] {
  1078.     set nm [lindex $f end]
  1079.     if {[string length $nm]} {
  1080.         if {[string match "d*" $f]} {
  1081.         #lappend files "$nm/"
  1082.         } else {
  1083.         regexp {[A-Z].*$} [lreplace $f end end] time
  1084.         set date [lindex $time end]
  1085.         if {![regexp {^19[89][0-5]$} $date]} {
  1086.             # reject anything pre 1996
  1087.             lappend files [list $nm $time]
  1088.         }
  1089.         }
  1090.     }
  1091.     }
  1092.     return $files
  1093. }
  1094.  
  1095. ## 
  1096.  # -------------------------------------------------------------------------
  1097.  # 
  1098.  # "remote::processhttpListing" --
  1099.  # 
  1100.  #  Extract all things like  <A HREF="/~vince/pub/">Parent Directory</A>
  1101.  #  followed by a date.  Massage the date into 'Month day year'.
  1102.  #  
  1103.  #  I don't know if this will work for all http servers!  It works for
  1104.  #  mine.
  1105.  # -------------------------------------------------------------------------
  1106.  ##
  1107. proc remote::processhttpListing {lines} {
  1108.     set files {}
  1109.     foreach f $lines {
  1110.     if {[regexp {<A HREF="([^"]*)">.*</A>[ \t]*([^ \t]+)[ \t]} $f "" name date]} {
  1111.         if {![regexp {/$} $name]} {
  1112.         if {![regexp {[89][0-5]$} $date]} {
  1113.             # reject anything pre 1996
  1114.             set date [split $date -]
  1115.             set md "[lindex $date 1] [lindex $date 0] "
  1116.             append md [expr {[lindex $date 2] < 80 ? 20 : 19}]
  1117.             append md [lindex $date 2]
  1118.             lappend files [list $name $md]
  1119.         }
  1120.         }
  1121.     }
  1122.     }
  1123.     return $files
  1124. }
  1125.  
  1126. proc remote::versionOneNewer {one two} {
  1127.     return 1
  1128. }
  1129.  
  1130. proc remote::processList {sitename {l ""}} {
  1131.     global remote::listing modifiedVars
  1132.     # removed vanished items from the menu
  1133.     regsub -all {(\.|-)[0-9]+([a-zA-Z][0-9]+)?} [set ll $l] "" ll
  1134.     foreach i ${remote::listing} {
  1135.     if {[string match "*${sitename}*" $i]} {
  1136.         regsub -all {(\.|-)([0-9]+([a-zA-Z][0-9]+)?)} \
  1137.           [set ii [lindex $i 2]] "" ii
  1138.         if {[lsearch -glob $ll "$ii *"] == -1} {
  1139.         # it's vanished
  1140.         lappend removed $i
  1141.         lappend _removed [lindex $i 0]
  1142.         }
  1143.     }
  1144.     }
  1145.     if {[info exists removed]} {
  1146.     set remote::listing [lremove -l ${remote::listing} $removed]
  1147.     }
  1148.     # process new items
  1149.     foreach i $l {
  1150.     set namepart [lindex $i 0]
  1151.     set timepart [lindex $i 1]
  1152.     regsub -all {\.(sit|bin|hqx)} [set name $namepart] "" name
  1153.     regsub -all {(\.|-)[0-9]+([a-zA-Z][0-9]+)?} $name "" name
  1154.     if {[set idx [lsearch -glob ${remote::listing} "${name} *"]] != -1} {
  1155.         # update old item
  1156.         set item [lindex ${remote::listing} $idx]
  1157.         if {[lindex $item 2] != $namepart} {
  1158.         # it's changed
  1159.         set item [lreplace $item 1 end 2 $namepart $timepart $sitename]
  1160.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1161.         lappend _updated $name
  1162.         } elseif {[date::isOlder [lindex $item 3] $timepart]} {
  1163.         # date has changed
  1164.         set item [lreplace $item 1 end 2 $namepart $timepart $sitename]
  1165.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1166.         lappend _updated $name
  1167.         }
  1168.     } else {
  1169.         # new package
  1170.         lappend remote::listing [list $name 0 $namepart $timepart $sitename]
  1171.         lappend _new $name
  1172.     }
  1173.     
  1174.     }
  1175.     lappend modifiedVars remote::listing
  1176.     package::makeMenu
  1177.     ensureset _updated "none"
  1178.     ensureset _new "none"
  1179.     ensureset _removed "none"
  1180.     if {[catch {alertnote "Remote information, NEW: $_new, UPDATED: $_updated, REMOVED: ${_removed}."}]} {
  1181.     alertnote "Remote information, [llength $_new] new, [llength $_updated] updated and [llength $_removed] packages removed."
  1182.     }
  1183. }
  1184. proc remote::updateDatabase {idx val} {
  1185.     global remote::listing
  1186.     set item [lindex ${remote::listing} $idx]
  1187.     if {[lindex $item 1] != $val} {
  1188.     # it's changed
  1189.     set item [lreplace $item 1 1 $val]
  1190.     set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1191.     }
  1192. }
  1193.  
  1194. proc remote::pkgIndex {name} { 
  1195.     global remote::listing
  1196.     if {[set i [lsearch -glob ${remote::listing} "${name} *"]] == -1} {
  1197.     set i [lsearch -glob ${remote::listing} \
  1198.       "[string toupper [string index ${name} 0]][string range $name 1 end] *"]
  1199.     }
  1200.     return $i
  1201. }
  1202.  
  1203. proc remote::pkgDetails {name} { 
  1204.     global remote::listing
  1205.     set idx [lsearch -glob ${remote::listing} "${name} *"]
  1206.     return [lindex ${remote::listing} $idx]
  1207. }
  1208.  
  1209. proc remote::get {pkg} {
  1210.     global remote::listing HOME remote::site downloadFolder file::separator
  1211.     # get pkg
  1212.     if {[set idx [remote::pkgIndex $pkg]] == -1} {
  1213.     alertnote "Sorry, I don't know from where to download that package."
  1214.     error ""
  1215.     }
  1216.     set item [lindex ${remote::listing} $idx]
  1217.     
  1218.     if {[set mods [expr {[getModifiers] & 0xfe}]]} {
  1219.     if {$mods & 34} {
  1220.         # just shift key demote the item in the hierarchy
  1221.         set itm [lindex $item 1]
  1222.         if {$itm == 0 || $itm == 2} { set itm 1 } else { set itm -2 }
  1223.         set item [lreplace $item 1 1 $itm]
  1224.         set remote::listing [lreplace ${remote::listing} $idx $idx $item]
  1225.         global modifiedVars
  1226.         lappend modifiedVars remote::listing
  1227.         package::makeMenu
  1228.         message "Package '$pkg' demoted."
  1229.         return
  1230.     } else {
  1231.         # describe the item
  1232.         alertnote "File '[lindex $item 2]', last modified [lindex $item 3], to be downloaded from [lindex $item 4], at [set remote::site([lindex $item 4])]"
  1233.         return
  1234.     }
  1235.     }
  1236.     set file [lindex $item 2]
  1237.     set sitename [lindex $item 4]
  1238.     # get the file
  1239.     if {![file exists $downloadFolder] || ![file isdirectory $downloadFolder]} {
  1240.     alertnote "Your Download Folder does not exist.  I'll download to Alpha's home directory."
  1241.     set downloadFolder $HOME
  1242.     }
  1243.     if {[catch {url::fetchFrom [set remote::site($sitename)] ${downloadFolder}${file::separator} $file} err]} {
  1244.     alertnote "Fetch error '$err'"
  1245.     error ""
  1246.     }
  1247.     if {![file exists $file] || (![file writable $file]) || (![file size $file])} {
  1248.     alertnote "It looks like that application returned control to me before the download was complete (otherwise there was an error) -- probably Netscape/IE.  When it's done, or if there was an error hit Ok."
  1249.     }
  1250.     # update database
  1251.     remote::updateDatabase $idx 1
  1252.     package::makeMenu
  1253.     # install
  1254.     set filepre [lindex [split $file .] 0]
  1255.     # decode the downloaded file (this may happen automatically)
  1256.     set f_encoded [glob -nocomplain [file join ${downloadFolder} "${filepre}*{.hqx,.bin}"]]
  1257.     set f_stuffed [glob -nocomplain [file join ${downloadFolder} "${filepre}*.sit"]]
  1258.     if {[llength $f_encoded] == 1} {
  1259.     if {[llength $f_stuffed] == 1} {
  1260.         # downloader was set to decode automatically --- we must wait
  1261.         set ff [lindex $f_stuffed 0]
  1262.         while {![file writable $ff]} {
  1263.         switchTo 'SITx'
  1264.         }
  1265.         switchTo 'ALFA'
  1266.     } else {
  1267.         # downloader not set to decode automatically
  1268.         set ff [lindex $f_encoded 0]
  1269.         message "Decoding [file tail $ff]…"
  1270.         set name [file tail [app::launchFore SITx]]
  1271.         sendOpenEvent -r 'SITx' $ff
  1272.     }
  1273.     }
  1274.     # decompress the downloaded file (this may happen automatically)
  1275.     set f_stuffed [glob -nocomplain [file join ${downloadFolder} "${filepre}*.sit"]]
  1276.     set f_results [glob -t TEXT -nocomplain [file join ${downloadFolder} "${filepre}*"]]
  1277.     eval lappend f_results [glob -nocomplain "[file join ${downloadFolder} ${filepre}*]${file::separator}"]
  1278.     set f_results [eval lremove [list $f_results] $f_stuffed $f_encoded]
  1279.     if {[llength $f_results] == 0} {
  1280.     # we didn't decompress automatically
  1281.     set ff [lindex $f_stuffed 0]
  1282.     message "Decompressing [file tail $ff]…"
  1283.     set name [file tail [app::launchFore SITx]]
  1284.     sendOpenEvent -r 'SITx' $ff        
  1285.     }
  1286.     # install
  1287.     set files [glob -t TEXT -nocomplain [file join ${downloadFolder} "${filepre}*"]]
  1288.     if {[llength $files] == 0} {
  1289.     # look for directory
  1290.     set dirs [glob -nocomplain "[file join ${downloadFolder} ${filepre}*]${file::separator}"]
  1291.     if {[llength $dirs] == 1} {
  1292.         set local [lindex $dirs 0]
  1293.         set files [glob -t TEXT -nocomplain "${local}*\[i|I\]{nstall,NSTALL}"]
  1294.     } else {
  1295.         set files ""
  1296.         set local $downloadFolder
  1297.     }
  1298.     }
  1299.     if {[llength $files] == 0} {
  1300.     alertnote "I can't find a suitable, unique install file.  You must find it yourself."
  1301.     # open dir in finder
  1302.     openFolder $local
  1303.     return
  1304.     }
  1305.     if {[llength $files] > 1} {
  1306.     set f [listpick -p "Which file is the installer?" $files]
  1307.     } else {
  1308.     set f [lindex $files 0]
  1309.     }
  1310.     edit $f
  1311.     global mode
  1312.     if {$mode != "Inst"} {
  1313.     alertnote "I don't know what to do with this package from here."
  1314.     } else {
  1315.     if {[dialog::yesno "You can install this extension from the install menu.\rShall I do that for you?"]} {
  1316.         install::installThisPackage
  1317.     }
  1318.     }
  1319. }
  1320.  
  1321.  
  1322.  
  1323.  
  1324.  
  1325.  
  1326.  
  1327.  
  1328.  
  1329.  
  1330.  
  1331.